home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 1
/
Cream of the Crop 1.iso
/
PROGRAM
/
SHUTTL.ARJ
/
SH.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1991-03-26
|
7KB
|
245 lines
{C-}
PROGRAM DEMO;
uses
crt,graph,gr_unt;
const
maxa =300;
maxv =124;
maxe =259;
data:array[1..631] of real = (
0,-2.2,46,1.5,-2.6,46,2.2,-4.6,46,1.7,-6.5,46,0,-6.7,46,
-1.7,-6.5,46,-2.2,-4.6,46,-1.5,-2.6,46,
0,-0.8,43,2.8,-1.5,43,4,-4.5,43,3,-7.2,43,0,-8,43,-3,-7.2,43,
-4,-4.5,43,-2.8,-1.5,43,
0,1.7,38,4.6,0,38,5.8,-4.4,38,4,-8.2,38,0,-9,38,-4,-8.2,38,
-5.8,-4.4,38,-4.6,0,38,
0,4,32.5,4.5,1,32.5,5.8,-4.6,32.5,4,-9,32.5,0,-9.5,32.5,-4,-9,32.5,
-5.8,-4.6,32.5,-4.5,1,32.5,
0,8,26.3,3.5,7,26.3,7.8,2,26.3,8,-7,26.3,0,-9.8,26.3,-8,-7,26.3,
-7.8,2,26.3,-3.5,7,26.3,
0,8,21.5,3.8,7.5,21.5,8,3,21.5,8,-8,21.5,0,-9.8,21.5,-8,-8,21.5,
-8,3,21.5,-3.8,7.5,21.5,
0,8,14,4.7,7,14,8,4,14,8,-8.7,14,0,-10,14,-8,-8.7,14,-8,4,14,
-4.7,7,14,
0,8,4,4.7,7,4,8,4,4,8,-8.7,4,0,-10,4,-8,-8.7,4,-8,4,4,
-4.7,7,4,
0,8,-12,4.7,7,-12,8,4,-12,8,-8.7,-12,0,-10,-12,-8,-8.7,-12,-8,4,-12,
-4.7,7,-12,
0,8,-27.3,4.7,7,-27.3,8,4,-27.3,8,-8.7,-27.3,0,-10,-27.3,-8,-8.7,-27.3,
-8,4,-27.3,-4.7,7,-27.3,
0,8,-35.6,4.7,7,-35.6,8,4,-35.6,8,-8.7,-35.6,0,-10,-35.6,-8,-8.7,-35.6,
-8,4,-35.6,-4.7,7,-35.6,
0,9,-43,2,8.5,-43,8.8,1.5,-43,9,-10,-43,0,-10.8,-43,-9,-10,-43,
-8.8,1.5,-43,-2,8.5,-43,
0,9.5,-48,2,9.3,-48,9.2,1.5,-48,10,-10,-48,0,-10.2,-48,-10,-10,-48,
-9.2,1.5,-48,-2,9.3,-48,
8.7,-8.7,21,15,-8.7,-16,35,-10,-36,35,-10,-40,
-8.7,-8.7,21,-15,-8.7,-16,-35,-10,-36,-35,-10,-40,
0,13,-37,0,33,-60,0,33,-69,0,14,-60,
6,11,-43,6,11,-48,11,5,-43,11,5,-48,-6,11,-43,-6,11,-48,-11,5,-43,
-11,5,-48,
-1,2,3,4,5,6,7,8,1,-9,10,11,12,13,14,15,16,9,-17,18,19,20,21,22,23,24,17,
-25,26,27,28,29,30,31,32,25,-33,34,35,36,37,38,39,40,33,
-41,42,43,44,45,46,47,48,41,-49,50,51,52,53,54,55,56,49,
-57,58,59,60,61,62,63,64,57,-65,66,67,68,69,70,71,72,65,
-73,74,75,76,77,78,79,80,73,-81,82,83,84,85,86,87,88,81,
-89,90,91,92,93,94,95,96,89,-97,98,99,100,101,102,103,104,97,
-1,9,17,25,33,41,49,57,65,73,81,89,97,
-2,10,18,26,34,42,50,58,66,74,82,90,98,
-3,11,19,27,35,43,51,59,67,75,83,91,99,
-4,12,20,28,36,44,52,60,68,76,84,92,100,
-5,13,21,29,37,45,53,61,69,77,85,93,101,
-6,14,22,30,38,46,54,62,70,78,86,94,102,
-7,15,23,31,39,47,55,63,71,79,87,95,103,
-8,16,24,32,40,48,56,64,72,80,88,96,104,
-44,105,106,107,108,92,
-46,109,110,111,112,94,
-81,113,114,115,116,89,
-82,117,118,-83,119,120,
-87,121,122,-88,123,124,
-117,119,-121,123,-118,120,-122,124);
var
oxangle,oyangle,ozangle,pc,ec:integer;
CH,SH,CP,SP,CB,SB,xv,yv,zv,
X,Y,Z,X3,Y3,Z3,AM,BM,CM,DM,
EM,FM,GM,HM,IM,D,P,B,H,U,vc,U1,V1:real;
V:array[1..maxa,1..3] of real;
E:array[1..maxa] of real;
saywhat:char;
procedure muck1;
begin
CH:=COS (H); SH:=SIN (H);
CP:=COS (P); SP:=SIN (P);
CB:=COS (B); SB:=SIN (B);
AM:=CB * CH - SH * SP * SB;
BM:=-CB * SH - SP * CH * SB;
CM:=CP * SB;
DM:=SH * CP;
EM:=CP * CH;
FM:=SP;
GM:=-CH * SB - SH * SP * CB;
HM:=SH * SB - SP * CH * CB;
IM:=CP * CB;
end;
procedure muck2;
begin
X:=X - XV;
Y:=Y - YV;
Z:=Z - ZV;
X3:=AM * X + BM * Y + CM * Z;
Y3:=DM * X + EM * Y + FM * Z;
Z3:=GM * X + HM * Y + IM * Z;
U:=135 + 13.5 * D * X3 / Y3;
Vc:=80 - 11.5 * D * Z3 / Y3;
end;
procedure muck3;
begin
X:=0;Y:=0;Z:=0;X3:=0;Y3:=0;Z3:=0;
AM:=0;BM:=0;CM:=0;DM:=0;EM:=0;
FM:=0;GM:=0;HM:=0;IM:=0;D:=0;P:=0;
B:=0;H:=0;U:=0;Vc:=0;U1:=0;V1:=0;
D:=120;
P:=6.28 * oxangle / 255 - 3.1416;
B:=6.28 * ozangle / 255;
H:=6.28 * oyangle / 255;
muck1;
XV:= -D * CP * SH;
YV:= -D * CP * CH;
ZV:= -D * SP;
FOR Ec:=1 TO maxe do
begin
X:= V[ABS(round(E [Ec])),1];
Y:= V[ABS(round(E [Ec])),2];
Z:= V[ABS(round(E [Ec])),3];
muck2;
IF E[Ec]>0
THEN LINE(round(U1*2+75),round(V1+20),round(U*2+75),round(Vc+20));
U1:= U; V1:= Vc;
end;
end;
procedure initvars;
var position,j:integer;
begin
position:=0;
FOR Pc:=1 TO maxv do
begin
for j:=1 to 3 do
begin
position:=position+1;
v[pc,j]:=data[position]*0.12;
end;
end;
FOR Ec:=1 TO maxe do
begin
position:=position+1;
e[ec]:=data[position];
end;
clrscr;
writeln('This is a TP 4.0 demo prog. It consists of a graphics initialization');
writeln('unit that recongnizes ANY available graphics display.');
writeln('There are three options: User, Tour and Random. Each option');
writeln('displays 3D views of the SHUTTLE on CGA, EGA, VGA, HERCULES, ATT etc.');
writeln;
writeln('The Tour option shows 3D views from different angles until a key is pressed.');
writeln('The Random option shows views from random angles until a key is pressed.');
writeln('The User option displays views from angles chosen by the user.');
writeln('To stop the program enter some non-integer for any of the angles.');
writeln('Hit return to move to next view.');
writeln;
writeln('I''ve found the structural coordinates for the shuttle on a BB in');
writeln('FORTRAN and BASIC readable format. I don''t know who the donors were');
writeln('but I do appreciate their perseverence (over 600 data points).');
writeln('Please improve this as you see fit (such as JOY STICK control)');
writeln('Eddy Vasile, CompuServe 73317,701');
oxangle:=0;
oyangle:=0;
ozangle:=0;
end;
procedure userangles;
var
junk:string[5];
rc:integer;
begin
rc:=0;
while rc=0 do
begin
gotoxy(20,21);
write('Enter inclination angle for OX: ');
readln(junk);
val(junk,oxangle,rc);
if rc<>0 then exit;
gotoxy(20,22);
write('Enter inclination angle for OY: ');
readln(junk);
val(junk,oyangle,rc);
if rc<>0 then exit;
gotoxy(20,23);
write('Enter inclination angle for OZ: ');
readln(junk);
val(junk,ozangle,rc);
if rc<>0 then exit;
gr_setup;
muck3;
readln(junk);
closegraph;
end;
end;
procedure tourangles;
begin
gr_setup;
while (oxangle<400) and (not keypressed) do
begin
setcolor(1);
muck3;
delay(800);
setcolor(0);
muck3;
oxangle:=oxangle+10;
oyangle:=oyangle+10;
ozangle:=ozangle+10;
end;
closegraph;
writeln('Thanks.. bye!');
if oxangle<350 then writeln('You should have waited a little more!');
end;
procedure randomangles;
begin
gr_setup;
while not keypressed do
begin
setcolor(1);
muck3;
delay(800);
setcolor(0);
muck3;
randomize;
oxangle:=round(random(400));
oyangle:=round(random(400));
ozangle:=round(random(400));
end;
closegraph;
writeln('Thanks.. bye!');
end;
begin
initvars;
gotoxy(20,20);
write('R)andom angles, U)ser angles, T)our (default = T) > ');
saywhat:=readkey;
case upcase(saywhat) of
'R':randomangles;
'U':userangles;
'T':tourangles;
else tourangles;
end;
end.